home *** CD-ROM | disk | FTP | other *** search
/ MacWorld UK 2000 March / MW_UK_2000_03.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / prefsHandling.tcl < prev    next >
Encoding:
Text File  |  1999-11-16  |  10.4 KB  |  429 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "prefsHandling.tcl"
  6.  #                                    created: 24/2/95 {9:52:30 pm} 
  7.  #                                last update: 11/16/1999 {19:31:53 PM} 
  8.  #  
  9.  # Reorganisation carried out by Vince Darley with much help from Tom 
  10.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  11.  # Alpha is shareware; please register with the author using the register 
  12.  # button in the about box.
  13.  #  
  14.  #  Description: 
  15.  # 
  16.  # Procedures for dealing with the user's preferences
  17.  # ###################################################################
  18.  ##
  19.  
  20. proc viewValue {name val} {
  21.     set header "'$name's value is:"
  22.     set response "\r$val\r"
  23.     if {[string length $val] > 80} {
  24.     if {([llength $val] > 3) && ([llength $val] > 6 || [string length $val] > 160)} {
  25.         listpick -p "'$name's value is:" $val
  26.     } else {
  27.         if {[tclLog $header$response]} {
  28.         global tileLeft tileTop tileWidth
  29.         new -g $tileLeft $tileTop $tileWidth 100 -n "* $name *" -m Text \
  30.           -info "'$name's value is:\r\r$val\r"
  31.         }
  32.     }
  33.     } else {
  34.     global mode
  35.     if {$mode == "Shel"} {
  36.         goto [maxPos]
  37.         tclLog $header$response
  38.         insertText [Alpha::Prompt]
  39.     } else {
  40.         alertnote "$header\r$response"
  41.     }
  42.     }
  43. }
  44.  
  45. namespace eval prefs {}
  46.  
  47. proc prefs::modified {what} {
  48.     global modifiedVars modifiedArrayElements
  49.     if {[regexp {([^(]+)\(([^)]+)\)} $what "" arr var]} {
  50.     lappend modifiedArrayElements [list $var $arr]
  51.     } else {
  52.     lappend modifiedVars $what
  53.     }    
  54. }
  55.  
  56. proc prefs::modifiedVar {var} {
  57.     global modifiedVars
  58.     lappend modifiedVars $var
  59. }
  60.  
  61. proc prefs::modifiedModeVar {var {m ""}} {
  62.     global modifiedArrayElements mode
  63.     if {$m == ""} { set m $mode }
  64.     lappend modifiedArrayElements [list $var ${m}modeVars]
  65. }
  66.  
  67. proc prefs::modifiedArrayElement {var arr} {
  68.     global modifiedArrayElements
  69.     lappend modifiedArrayElements [list $var $arr]
  70. }
  71.  
  72. proc prefs::add {def val {prefix {}}} {
  73.     global ${prefix}prefDefs
  74.     
  75.     prefs::_read $prefix
  76.     set ${prefix}prefDefs($def) $val
  77.     prefs::_write $prefix
  78.     catch {unset ${prefix}prefDefs}
  79. }
  80.  
  81. proc prefs::remove {def {prefix {}}} {
  82.     global ${prefix}prefDefs
  83.     
  84.     prefs::_read $prefix
  85.     catch {unset ${prefix}prefDefs($def)}
  86.     prefs::_write $prefix
  87.     catch {unset ${prefix}prefDefs}
  88. }
  89.  
  90. proc prefs::addArrayElement {arr def val} {
  91.     prefs::add [list $arr $def] $val arr
  92. }
  93.  
  94. proc prefs::removeArrayElement {arr def} {
  95.     prefs::remove [list $arr $def] arr
  96. }
  97.  
  98. proc prefs::removeArray {arr} {
  99.     global arrprefDefs $arr
  100.     
  101.     prefs::_read arr
  102.     foreach def [array names $arr] {
  103.     catch {unset arrprefDefs([list $arr $def])}
  104.     }
  105.     prefs::_write arr
  106.     catch {unset arrprefDefs}
  107. }
  108.  
  109. proc prefs::addArray {arr} {
  110.     global arrprefDefs $arr
  111.     
  112.     prefs::_read arr
  113.     foreach def [array names $arr] {
  114.     catch {set arrprefDefs([list $arr $def]) [set ${arr}($def)]}
  115.     }
  116.     prefs::_write arr
  117.     catch {unset arrprefDefs}
  118. }
  119.  
  120. proc prefs::_read {{prefix {}}} {
  121.     global PREFS
  122.     if {![file exists [file join $PREFS ${prefix}defs.tcl]]} return
  123.     uplevel \#0 [list source [file join $PREFS ${prefix}defs.tcl]]
  124. }
  125.  
  126. proc prefs::_write {{prefix {}}} {
  127.     global PREFS ${prefix}prefDefs 
  128.     
  129.     if {![info exists ${prefix}prefDefs]} {
  130.     catch {file delete [file join $PREFS ${prefix}defs.tcl]}
  131.     return
  132.     }
  133.     
  134.     if {![file exists "$PREFS"]} {
  135.     file mkdir "$PREFS"
  136.     }
  137.     set fd [open [file join $PREFS ${prefix}defs.tcl] "w"]
  138.     foreach nm [array names ${prefix}prefDefs] {
  139.     puts $fd [list set ${prefix}prefDefs($nm) [set ${prefix}prefDefs($nm)]]
  140.     }
  141.     close $fd
  142. }
  143.  
  144.  
  145. proc prefs::readAll {} {
  146.     namespace eval :: {
  147.     global prefDefs arrprefDefs PREFS
  148.     
  149.     if {[file exists [file join $PREFS defs.tcl]]} {
  150.         source [file join $PREFS defs.tcl]
  151.         
  152.         foreach nm [array names prefDefs] {
  153.         global $nm
  154.         if {[catch {set $nm $prefDefs($nm)}]} {
  155.             set ns ""
  156.             while {[regexp "^($ns\[a-zA-Z_\]+::)" $nm ns]} {
  157.             namespace eval $ns {}
  158.             }
  159.             set $nm $prefDefs($nm)
  160.         }
  161.         
  162.         }
  163.         catch {unset prefDefs}
  164.     }
  165.     
  166.     if {[file exists [file join $PREFS arrdefs.tcl]]} {
  167.         source [file join $PREFS arrdefs.tcl]
  168.         
  169.         foreach nm [array names arrprefDefs] {
  170.         set arr [lindex $nm 0]
  171.         set field [lindex $nm 1]
  172.         set val $arrprefDefs($nm)
  173.         global $arr
  174.         set ${arr}($field) $val
  175.         if {[catch {set ${arr}($field) $val}]} {
  176.             set ns ""
  177.             while {[regexp "^($ns\[a-zA-Z_\]+::)" $arr ns]} {
  178.             namespace eval $ns {}
  179.             }
  180.             set ${arr}($field) $val
  181.         }
  182.         }
  183.         catch {unset arrprefDefs}
  184.     }
  185.     }
  186.     
  187. }
  188.  
  189.  
  190. proc prefs::tclRead {} {
  191.     global PREFS
  192.     # Use "prefs.tcl" to define or change any tcl information. 
  193.     if {![file exists [file join $PREFS prefs.tcl]]} {
  194.     if {![file exists "$PREFS"]} {
  195.         file mkdir "$PREFS"
  196.     }
  197.     set fd [open [file join $PREFS prefs.tcl] "w"]
  198.     close $fd
  199.     }
  200.     uplevel #0 {
  201.     if {[catch {source [file join $PREFS prefs.tcl]}]} {
  202.         if {[dialog::yesno "An error occurred while loading \"prefs.tcl\".  Shall I make a trace on the error?"]} {
  203.         dumpTraces "prefs.tcl error" $errorInfo
  204.         }
  205.     }
  206.     }
  207. }
  208.  
  209.     
  210. proc prefs::viewSavedSetting {} {
  211.     global prefDefs arrprefDefs
  212.     
  213.     prefs::saveModified
  214.     
  215.     if {[catch {listpick -p "The following settings have been saved:" [prefs::listAllSaved]} res]} {
  216.     return
  217.     }
  218.     
  219.     if {[regexp {([^(]+)\(([^)]+)\)} $res "" arr field]} {
  220.     set arg [list $arr $field]
  221.     set val $arrprefDefs($arg)
  222.     } else {
  223.     global $res
  224.     set val $prefDefs($res)
  225.     }    
  226.     viewValue $res $val
  227.     catch {unset prefDefs}
  228.     catch {unset arrprefDefs}
  229. }
  230.  
  231. ## 
  232.  # -------------------------------------------------------------------------
  233.  # 
  234.  # "removeSavedSetting" --
  235.  # 
  236.  #  This proc shouldn't 'unset' the variables it removes, because most
  237.  #  such variables will be in use/have default values until restart.
  238.  # -------------------------------------------------------------------------
  239.  ##
  240. proc prefs::removeSavedSetting {} {
  241.     global prefDefs arrprefDefs
  242.     
  243.     prefs::saveModified
  244.     if {[catch {listpick -p "Remove which setting?" [lsort -ignore [prefs::listAllSaved]]} res]} {
  245.     return
  246.     }
  247.     
  248.     if {$res == ""} return
  249.     if {[regexp {([^(]+)\(([^)]+)\)} $res "" arr field]} {
  250.     global $arr
  251.     prefs::removeArrayElement $arr $field
  252.     } else {
  253.     global $res
  254.     prefs::remove $res
  255.     }
  256.     
  257.     catch {unset prefDefs}
  258.     catch {unset arrprefDefs}
  259. }
  260.  
  261.  
  262. proc prefs::listAllSaved {} {
  263.     global prefDefs arrprefDefs
  264.     
  265.     prefs::_read
  266.     prefs::_read arr
  267.     
  268.     set names [array names prefDefs]
  269.     foreach pair [array names arrprefDefs] {
  270.     lappend names "[lindex $pair 0]([lindex $pair 1])"
  271.     }
  272.     
  273.     return [lsort $names]
  274. }
  275.  
  276. #===============================================================================
  277.  
  278. proc prefs::tclEdit {} {
  279.     global PREFS
  280.     if {![file exists [file join $PREFS prefs.tcl]]} {
  281.     set fd [open [file join $PREFS prefs.tcl] "w"]
  282.     close $fd
  283.     }
  284.     edit [file join $PREFS prefs.tcl]
  285. }
  286.  
  287. # Automatically add a line to the user input file
  288. proc prefs::tclAddLine {line} {
  289.     global PREFS
  290.     
  291.     if {![file exists "$PREFS"]} {
  292.     file mkdir "$PREFS"
  293.     }
  294.     set fid [open [file join $PREFS prefs.tcl] "a+"]
  295.     if {![catch {seek $fid -1 end}]} {
  296.     if {![regexp "\[\r\n\]" [read $fid 1]]} {
  297.         set line "\r$line"
  298.     }
  299.     }
  300.     seek $fid 0 end
  301.     puts $fid $line
  302.     close $fid
  303. }
  304.  
  305. # Automatically add a line to a mode's pref file -trf
  306. proc prefs::tclAddModeLine {line} {
  307.     global PREFS mode
  308.     
  309.     if {![file exists "$PREFS"]} {
  310.     file mkdir "$PREFS"
  311.     }
  312.     set fid [open [file join $PREFS ${mode}prefs.tcl] "a+"]
  313.     if {![catch {seek $fid -1 end}]} {
  314.     if {[read $fid 1] != "\r"} {
  315.         set line "\r$line"
  316.     }
  317.     }
  318.     seek $fid 0 end
  319.     puts $fid $line
  320.     close $fid
  321. }
  322.  
  323. proc prefs::saveNow {} {
  324.     global modifiedVars modifiedModeVars modifiedArrVars \
  325.       mode::features prefDefs modifiedArrayElements global::features \
  326.       alpha::earlyPrefs
  327.     
  328.     cache::delete configuration
  329.     cache::add configuration list global::features
  330.     
  331.     if {[info exists alpha::earlyPrefs]} {
  332.     foreach f [set alpha::earlyPrefs] {
  333.         global $f
  334.         if {[info exists $f]} {
  335.         cache::add configuration variable $f
  336.         }
  337.     }
  338.     } else {
  339.     set alpha::earlyPrefs {}
  340.     }
  341.     
  342.     foreach f [lunique $modifiedArrVars] {
  343.     prefs::addArray $f
  344.     }
  345.     foreach f [lunique $modifiedVars] {
  346.     if {[lsearch -exact [set alpha::earlyPrefs] $f] == -1} {
  347.         global $f
  348.         if {[info exists $f]} {
  349.         prefs::add $f [set $f]
  350.         } else {
  351.         prefs::remove $f
  352.         }
  353.     }
  354.     }
  355.     # these two lists actually behave identically
  356.     foreach f [concat [lunique $modifiedArrayElements]  [lunique $modifiedModeVars]] {
  357.     set elt [lindex $f 0]
  358.     set arr [lindex $f 1]
  359.     global $arr
  360.     if {[info exists [set arr]($elt)]} {
  361.         prefs::addArrayElement [set arr] $elt [set [set arr]($elt)]
  362.     } else {
  363.         prefs::removeArrayElement [set arr] $elt
  364.     }
  365.     }
  366.     message "Preferences saved"
  367. }
  368.  
  369. proc prefs::saveModified {} {
  370.     global modifiedVars modifiedModeVars modifiedArrVars \
  371.       modifiedArrayElements
  372.     prefs::saveNow
  373.     set modifiedVars {}
  374.     set modifiedArrVars {}
  375.     set modifiedModeVars {}
  376.     set modifiedArrayElements {}
  377. }
  378.  
  379.  
  380. #===============================================================================
  381.  
  382. namespace eval mode {}
  383.  
  384. ## 
  385.  # -------------------------------------------------------------------------
  386.  # 
  387.  # "mode::sourcePrefsFile" --
  388.  # 
  389.  #  Fixes 'uplevel #0' problem
  390.  # -------------------------------------------------------------------------
  391.  ##
  392. proc mode::sourcePrefsFile {} { 
  393.     global mode PREFS
  394.     if {[file exists [file join ${PREFS} ${mode}Prefs.tcl]]} {
  395.     uplevel #0 [list source [file join ${PREFS} ${mode}Prefs.tcl]]
  396.     } else {
  397.     beep; message "Sorry, no preferences for '$mode' mode"
  398.     }
  399. }
  400.  
  401. proc mode::editPrefsFile {{m ""}} { 
  402.     global PREFS mode
  403.     if {$m == ""} { set m $mode }
  404.     message $m
  405.     # assume it is a mode, since we made the menu
  406.     
  407.     set f [file join $PREFS ${m}Prefs.tcl]
  408.     if {[file exists $f]} {
  409.     edit $f
  410.     } else {
  411.     if {[dialog::yesno "No '$m' prefs file exists, do you want to create one?"]} {
  412.         close [open $f "w"]
  413.         edit $f
  414.         insertText {
  415. ## 
  416.  # This    file will be sourced automatically, immediately after 
  417.  # the _first_ time the file which defines its mode is sourced.
  418.  # Use this file to insert your own mode-specific preferences
  419.  # and changes,    rather than altering the originals.
  420.  # 
  421.  # You can redefine menus, procedures, variables,...
  422.  ##
  423.  
  424.     }}}
  425.     
  426.     hook::callAll mode::editPrefsFile
  427. }
  428.  
  429.